home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / netmail / txtq130.zip / SRQ.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-26  |  7KB  |  215 lines
  1. {$M 10240,0,655360}  { 10k reserved for data }
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I- disable I/O checking (trap errors by checking IOResult)}
  5.  
  6. PROGRAM Convert_SPEED_savefiles_to_QWK;
  7. USES
  8.   DOS,
  9.   TXTQ;
  10. VAR
  11.   SavedExitProc: POINTER;
  12.  
  13. {===========================================================================}
  14.  
  15. PROCEDURE CustomExit; FAR;
  16. {---- Always exit through here ----}
  17. BEGIN
  18.   ExitProc := SavedExitProc;
  19.   cursorOn;
  20.   Cleanup;
  21.   IF (ExitCode > 0) THEN BEGIN
  22.     WriteLn;
  23.     WriteLn ('SRQ - Free DOS utility: Convert SPEED READ "save files" to QWK files.');
  24.     WriteLn (author);
  25.     WriteLn;
  26.     WriteLn ('Usage:  SRQ <SPEED "save file(s)">        (DOS wildcards are permitted.)');
  27.     WriteLn;
  28.     WriteLn ('Example:  SRQ startrek.txt                (creates "STARTREK.Q??")');
  29.     WriteLn;
  30.   END;
  31.   IF ErrorAddr <> NIL THEN
  32.   BEGIN
  33.     WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
  34.     WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
  35.     WriteLn ('Code    = ', ExitCode);
  36.     ErrorAddr := NIL;
  37.   END
  38.   ELSE
  39.     IF (ExitCode > 0) AND (ExitCode < 255) THEN
  40.       WriteErr (ExitCode);
  41. END;
  42.  
  43. FUNCTION GetMsgTime (timestr: STRING): STRING;
  44. VAR
  45.   MsgTime: STRING [5];
  46.   hours: BYTE;
  47.   VErr: INTEGER;
  48. BEGIN
  49.   MsgTime := Copy (timestr, 30, 5);
  50.   IF (Copy (timestr, 35, 1) = 'p') AND (Copy (MsgTime, 1, 2) <> '12') THEN BEGIN
  51.     Val (Copy (MsgTime, 1, 2), hours, VErr);
  52.     Inc (hours, 12);
  53.     MsgTime := LeadingZero (hours) + Copy (MsgTime, 3, 3);
  54.   END;
  55.   GetMsgTime := MsgTime;
  56. END;
  57.  
  58. FUNCTION GetMsgStat (Status: CHAR): CHAR;
  59. BEGIN
  60.   IF (Status = 'u')
  61.    THEN GetMsgStat := #32       { unread, public }
  62.    ELSE GetMsgStat := #42       { unread, private }
  63. END;
  64.  
  65. FUNCTION ReadMsgHeader (VAR Msgfile: FILE): STRING;
  66. CONST
  67.   hyphens = '---------------------------------------' +
  68.             '----------------------------------------';
  69.   Msgpass = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
  70.   Msgchnk = #32#32#32#32#32#32;  { 6 spaces }
  71.  
  72. VAR
  73.   Msgline: STRING;
  74.   Msgfrom, Msgto, Msgsubj: STRING [25];
  75.   Msgdate: STRING [8];  Msgtime: STRING [5];
  76.   Msgnumb: STRING [7];  Msgrfer: STRING [8];
  77.   ConfNum: STRING [5];  MsgStat: CHAR;
  78.   Count: BYTE;
  79.  
  80. BEGIN
  81.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  82.   Verify (Msgline, 'Date:',   6); Msgdate := Copy (Msgline, 12, 8);
  83.   Verify (Msgline, 'Time:',  24); MsgTime := GetMsgTime (Msgline);
  84.   Verify (Msgline, 'Number:',41); Msgnumb := RPad (Copy (Msgline, 49, Length (Msgline) - 48), 7, #32);
  85.  
  86.   for count := 1 to 2 do begin
  87.     ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  88.  
  89.     if Copy (MsgLine, 6, 5) = 'From:' then
  90.       Msgfrom := Copy (Msgline, 12, 25)
  91.     else
  92.     if Copy (MsgLine, 8, 3) = 'To:' then
  93.       Msgto := Copy (Msgline, 12, 25);
  94.  
  95.     if count = 1 then begin
  96.       Verify (Msgline, 'Refer:', 42);
  97.       Msgrfer := RPad (Copy (Msgline, 49, Length (Msgline) - 48), 8, #32);
  98.     end
  99.     else
  100.     if count = 2 then begin
  101.     (* Verify (Msgline, 'Recvd:', 65); MsgStat := Msgline[72]; <- SPEED v2.00 changed this *)
  102.       IF BBSname = '' THEN
  103.         BBSname := Trim (Copy (Msgline, 49, 15));
  104.     end;
  105.   end;
  106.  
  107.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  108.   Verify (Msgline, 'Subject:', 3); Msgsubj := Copy (Msgline, 12, 25);
  109.   Verify (Msgline, ':',       47); ConfNum := StrToDoubleChar (Copy (Msgline, 42, 5));
  110.   Verify (Msgline, 'Status:', 64); MsgStat := GetMsgStat (Msgline [73]);
  111.  
  112.   AddConfToList (ConfNum, Trim (Copy (Msgline, 49, 15)));
  113.   AddMsgToList (ConfNum, Blocks);
  114.  
  115.   ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);  {discard hyphen line}
  116.   Verify (Msgline, hyphens, 1);
  117.  
  118.   ReadMsgheader := (MsgStat + Msgnumb + Msgdate+ MsgTime+    {  1+7+8+5 = 21 }
  119.                     Msgto + Msgfrom + Msgsubj +              { 25+25+25 = 75 }
  120.                     Msgpass + Msgrfer + Msgchnk + #225 +     { 12+8+6+1 = 27 }
  121.                     ConfNum + #0#0#42);                      { 2+3      =  5 }
  122. END;
  123.  
  124. {===========================================================================}
  125.  
  126. CONST
  127.   SepLine = '=======================================' +
  128.             '========================================';
  129.  
  130. VAR
  131.   Msgname: PATHSTR;
  132.   Msgext : EXTSTR;
  133.   Msgfile: FILE;     DATfile : FILE;
  134.   Msgline: STRING;   Message : MsgArray;
  135.   index, bytes, chunks: WORD;
  136.   Compressor : PATHSTR;
  137.  
  138.   dirinfo   : SEARCHREC;  { contains filespec info. }
  139.   spath     : PATHSTR;    { source file path and    }
  140.   sdir      : DIRSTR;     {             directory   }
  141.   filesdone : WORD;
  142.  
  143. BEGIN
  144.   SavedExitProc := ExitProc;
  145.   ExitProc := @CustomExit;
  146.  
  147.   IF ParamCount <> 1
  148.     THEN Halt (255)
  149.     ELSE spath := GetFilePath (ParamStr (1), sDir);
  150.  
  151.   FindFirst (spath, Archive, dirinfo);
  152.   filesdone := 0;
  153.  
  154.   MkDir (TXTQ_DIR); CheckIO;
  155.   ChDir (TXTQ_DIR); CheckIO;
  156.  
  157.   WHILE (DosError = 0) DO BEGIN
  158.     BBSname := '';
  159.     ConfList := NIL;
  160.     MsgList := NIL;
  161.     Conferences := 0;
  162.  
  163.     Inc (filesdone);
  164.     Msgname := sdir + dirinfo. Name;
  165.     PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
  166.     Blocks := 0;
  167.     Chunks := 2;
  168.     ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  169.     REPEAT
  170.       IF (NOT EoF (Msgfile)) AND (Msgline = SepLine) THEN BEGIN
  171.         bytes := 0;  updateCursor;
  172.  
  173.         Inc (Blocks, chunks);
  174.         Msgline := ReadMsgHeader (Msgfile);
  175.  
  176.         WHILE (NOT EoF (Msgfile)) AND (Msgline <> SepLine) DO BEGIN
  177.           IF (bytes < MaxBytes) THEN
  178.             bytes := AddToArray (Message, bytes, Msgline);
  179.           ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  180.         END;
  181.         IF (bytes > MaxBytes) THEN bytes := MaxBytes;
  182.         WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
  183.           Dec (bytes);
  184.  
  185.         index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
  186.         IF (chunks > 1) THEN BEGIN
  187.           FOR index := (bytes + 1) TO (chunks * 128) DO
  188.             Message [index] := #32;
  189.         END;
  190.  
  191.         BlockWrite (DATfile, Message, chunks * 128); CheckIO;
  192.  
  193.       END
  194.       ELSE BEGIN
  195.         ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
  196.       END;
  197.     UNTIL EoF (Msgfile);
  198.  
  199.     Close (Msgfile); CheckIO;
  200.     Close (DATfile); CheckIO;
  201.     WriteLn ('done!');
  202.  
  203.     InitConfig (Compressor);
  204.     Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
  205.     IF CompressDat (Msgname + Msgext, Compressor)
  206.       THEN WriteLn ('done!')
  207.       ELSE Halt (5);
  208.  
  209.     FindNext (dirinfo);
  210.   END;
  211.   IF (filesdone = 0)
  212.     THEN Halt (1)
  213.     ELSE WriteLn ('Processed ', filesdone, ' file(s).');
  214. END.
  215.